home *** CD-ROM | disk | FTP | other *** search
/ Amiga Collections: Camelot / Camelot 098 (1990-12)(Swedish User Group of Amiga)(SE)(PD)[WB].zip / Camelot 098 (1990-12)(Swedish User Group of Amiga)(SE)(PD)[WB].adf / XLisp-Stat / Functions / handrotate.lsp < prev    next >
Text File  |  1990-10-11  |  1KB  |  37 lines
  1. ; book pp.309-310
  2.  
  3. (send spin-proto :add-mouse-mode 'hand-rotate
  4.    :title "Hand Rotate"
  5.    :cursor 'hand
  6.    :click :do-hand-rotate)
  7. (defmeth spin-proto :canvas-to-sphere (x y rad)
  8.   (let* ((p (send self :canvas-to-scaled x y))
  9.          (x (first p))
  10.          (y (second p))
  11.          (norm-2 (+ (* x x) (* y y)))
  12.          (rad-2 (^ rad 2))
  13.          (z (sqrt (max (- rad-2 norm-2) 0))))
  14.      (if (< norm-2 rad-2)
  15.          (list x y x)
  16.          (let ((r (sqrt (/ norm-2 rad-2))))
  17.            (list (/ x r) (/ y r) (/ z r))))))
  18. (defmeth spin-proto :do-hand-rotate (x y m1 m2)
  19.   (let* ((m (send self :num-variables))
  20.          (range (send self :scaled-range 0))
  21.          (rad (/ (apply #'- range) 2))
  22.          (oldp (send self :canvas-to-sphere x y rad))
  23.          (p oldp)
  24.          (vars (send self :content-variables))
  25.          (trans (identity-matrix m)))
  26.       (flet ((spin-sphere (x y)
  27.            (setf oldp p)
  28.            (setf p (send self :canvas-to-sphere x y rad))
  29.            (setf (select trans vars vars) (make-rotation oldp p))
  30.            (when m1
  31.                  (send self :rotation-type trans)
  32.                  (send self :idle-on t))
  33.            (send self :apply-transformation trans)))
  34.    (send self :idle-on nil)
  35.    (send self :while-button-down #'spin-sphere))))
  36.  
  37.